Problem Description

Find the minimum value of the following \(f(x_1, x_2)\) function where \(-10 \leq x_1, x_2 \leq 10\) by using simulated annealing algorithm.

\[ f(x_1, x_2) = -\left\lvert{\sin(x_1) \cos(x_2) \exp\biggl(\left\lvert{1 - \frac{\sqrt{{x_1}^2 + {x_2}^2}}{\pi}}\right\rvert\biggr)}\right\rvert \]

Implementation

We will implements the simulated annealing algorithm in R. The visualization (by plotly) also included.

library(plotly)

The Function \(f(x_1, x_2)\) in R

f <- (function(x1, x2)
  -abs(sin(x1) * cos(x2) * exp(abs(1 - (sqrt((x1 ** 2) + (x2 ** 2)) / pi))))
)

Initializing Contour Plot

In this report, I’m learning about how to visualize my data. As the getting started, we will see the initial contour plot below. How? First, we need a function to generate a (matrix) mesh grid. It is a two dimensional matrix. Then, fill it up by using \(f(x_1, x_2)\) above.

# A function for generating mesh grid
meshgrid <- function(x1, x2 = x1) {
  n <- length(x1)
  m <- length(x2)
  
  X1 <- matrix(rep(x1, each = m), nrow = m, ncol = n)
  X2 <- matrix(rep(x2, each = n), nrow = m, ncol = n)
  
  return(list(X1, X2))
}
 
# The generated mesh grid
seq <- seq(-10.0, 10.0, by = 0.1)
mesh_grid <- meshgrid(seq)
mesh_grid_x1 <- mesh_grid[[1]]
mesh_grid_x2 <- mesh_grid[[2]]
 
# Re-initialize `mesh_grid` variable
mesh_grid <- mesh_grid_x1
dim <- dim(mesh_grid)
 
# Fill up `mesh_grid` by using f(x1, x2)
for (i in 1:dim[[1]])
  for (j in 1:dim[[2]])
    mesh_grid[[i, j]] <- f(mesh_grid_x1[[i, j]], mesh_grid_x2[[i, j]])
 
# Display the contour plot
plot_ly(
  x = seq,
  y = seq,
  z = mesh_grid,
  type = "contour",
  contours = list(coloring = "heatmap"),
  hoverinfo = "none"
) %>% colorbar(title = "Value of f(x1, x2)") %>% layout(
  xaxis = list(title = "x1", showticklabels = TRUE),
  yaxis = list(title = "x2", showticklabels = TRUE)
)

The contour plot above is the generated value from all \(x_1\) and \(x_2\) where \(-10 \leq x_1, x_2 \leq 10\) in \(f(x_1, x_2)\) function. The solution is nowhere in the plot. Since we want to find its minimum value, we could predict that the solution is on the dark purple colored area.

Simulated Annealing Implementation

# Initialize random solution
start <- list(x1 = -2, x2 = 5, temperature = 1000)
start <- c(start, list(acceptance = f(start$x1, start$x2)))
 
# Initialize current solution
current <- start
best <- c(current, acceptance = f(current$x1, current$x2))
 
# Generate random point (x1, x2)
generate <- (function() runif(1, -10, 10))
# Initialize a new mesh grid for z = f(x, y)
mesh_grid_x <- c()
mesh_grid_y <- c()
mesh_grid_z <- c()
 
# Main simulated annealing algorithm
while (current$temperature > 0) {
  # Generate a new random solution
  newly <- list(x1 = generate(), x2 = generate())
  newly <- c(newly, acceptance = f(newly$x1, newly$x2))
  
  # Energy changes a.k.a \Delta E
  changes <- newly$acceptance - current$acceptance
  
  if (changes < 0) {
    current$x1 <- newly$x1
    current$x2 <- newly$x2
    
    current$acceptance <- newly$acceptance
    
    # Adding a new value for each mesh grid
    mesh_grid_x <- c(mesh_grid_x, current$x1)
    mesh_grid_y <- c(mesh_grid_y, current$x2)
    mesh_grid_z <- c(mesh_grid_z, current$acceptance)
    
    if (newly$acceptance < best$acceptance) {
      best$x1 <- newly$x1
      best$x2 <- newly$x2
      
      best$acceptance <- newly$acceptance
    }
  }
  else {
    # Considering move to the current (x1, x2)
    P <- exp((-changes) / current$temperature)
    R <- runif(1)
    
    if (R < P) {
      current$x1 <- newly$x1
      current$x2 <- newly$x2
    }
  }
  
  # Decrease the temperature randomly
  current$temperature <- current$temperature - runif(1, 0.0001, 0.01)
}
# Retrieve the solution and then print it
solution <- list(x1 = best$x1, x2 = best$x2, value = best$acceptance)
print(solution)
$x1
[1] -8.049689

$x2
[1] 9.661877

$value
[1] -19.20814

By using simulated annealing above, we got the solution. It is \((-8.049689, 9.661877)\) in the form of \((x_1, x_2)\). The value of \(f(x_1, x_2)\) is \(-19.20814\). Remember that the solution could be a bit different if we start over and run the algorithm again. However, the result would be around \(-19\).

Display the Contour Plot

plot_ly(
  x = mesh_grid_x,
  y = mesh_grid_y,
  z = mesh_grid_z,
  type = "contour",
  hoverinfo = "none",
  contours = list(coloring = "heatmap")
) %>% colorbar(title = "Value of f(x1, x2)") %>% layout(
  xaxis = list(title = "x1", showticklabels = TRUE),
  yaxis = list(title = "x2", showticklabels = TRUE)
)

We all know that the solution is around \(-19\) and it is produced by (around) \((8.0, 9.7)\). Hence, by looking at the contour plot above, the solution is on the that dark purple color.

LS0tCnRpdGxlOiAiU2ltdWxhdGVkIEFubmVhbGluZyIKYXV0aG9yOiAiV2lzbnUgQWRpIE51cmNhaHlvIgpkYXRlOiAiU2VwdGVtYmVyIDIwdGgsIDIwMTgiCgpvdXRwdXQ6CiAgaHRtbF9ub3RlYm9vazoKICAgIGNzczogcHJlc2VudGF0aW9uLmNzcwotLS0KCiMjIFByb2JsZW0gRGVzY3JpcHRpb24KCkZpbmQgdGhlICoqbWluaW11bSB2YWx1ZSoqIG9mIHRoZSBmb2xsb3dpbmcgJGYoeF8xLCB4XzIpJCBmdW5jdGlvbiB3aGVyZSAkLTEwIFxsZXEgeF8xLCB4XzIgXGxlcSAxMCQKYnkgdXNpbmcgKipzaW11bGF0ZWQgYW5uZWFsaW5nKiogYWxnb3JpdGhtLgoKJCQKZih4XzEsIHhfMikgPSAtXGxlZnRcbHZlcnR7XHNpbih4XzEpIFxjb3MoeF8yKSBcZXhwXGJpZ2dsKFxsZWZ0XGx2ZXJ0ezEgLSBcZnJhY3tcc3FydHt7eF8xfV4yICsge3hfMn1eMn19e1xwaX19XHJpZ2h0XHJ2ZXJ0XGJpZ2dyKX1ccmlnaHRccnZlcnQKJCQKCiMjIEltcGxlbWVudGF0aW9uCgpXZSB3aWxsIGltcGxlbWVudHMgdGhlIHNpbXVsYXRlZCBhbm5lYWxpbmcgYWxnb3JpdGhtIGluIFIuClRoZSB2aXN1YWxpemF0aW9uIChieSBgcGxvdGx5YCkgYWxzbyBpbmNsdWRlZC4KCmBgYHtyIG1lc3NhZ2UgPSBGQUxTRX0KbGlicmFyeShwbG90bHkpCmBgYAoKCiMjIyBUaGUgRnVuY3Rpb24gJGYoeF8xLCB4XzIpJCBpbiBSCgpgYGB7cn0KZiA8LSAoZnVuY3Rpb24oeDEsIHgyKQogIC1hYnMoc2luKHgxKSAqIGNvcyh4MikgKiBleHAoYWJzKDEgLSAoc3FydCgoeDEgKiogMikgKyAoeDIgKiogMikpIC8gcGkpKSkpCikKYGBgCgoKIyMjIEluaXRpYWxpemluZyBDb250b3VyIFBsb3QKCkluIHRoaXMgcmVwb3J0LCBJJ20gbGVhcm5pbmcgYWJvdXQgaG93IHRvIHZpc3VhbGl6ZSBteSBkYXRhLgpBcyB0aGUgZ2V0dGluZyBzdGFydGVkLCB3ZSB3aWxsIHNlZSB0aGUgaW5pdGlhbCBjb250b3VyIHBsb3QgYmVsb3cuCkhvdz8gRmlyc3QsIHdlIG5lZWQgYSBmdW5jdGlvbiB0byBnZW5lcmF0ZSBhIChtYXRyaXgpIG1lc2ggZ3JpZC4KSXQgaXMgYSB0d28gZGltZW5zaW9uYWwgbWF0cml4LiBUaGVuLCBmaWxsIGl0IHVwIGJ5IHVzaW5nICRmKHhfMSwgeF8yKSQgYWJvdmUuCgpgYGB7cn0KIyBBIGZ1bmN0aW9uIGZvciBnZW5lcmF0aW5nIG1lc2ggZ3JpZAptZXNoZ3JpZCA8LSBmdW5jdGlvbih4MSwgeDIgPSB4MSkgewogIG4gPC0gbGVuZ3RoKHgxKQogIG0gPC0gbGVuZ3RoKHgyKQogIAogIFgxIDwtIG1hdHJpeChyZXAoeDEsIGVhY2ggPSBtKSwgbnJvdyA9IG0sIG5jb2wgPSBuKQogIFgyIDwtIG1hdHJpeChyZXAoeDIsIGVhY2ggPSBuKSwgbnJvdyA9IG0sIG5jb2wgPSBuKQogIAogIHJldHVybihsaXN0KFgxLCBYMikpCn0KIAojIFRoZSBnZW5lcmF0ZWQgbWVzaCBncmlkCnNlcSA8LSBzZXEoLTEwLjAsIDEwLjAsIGJ5ID0gMC4xKQptZXNoX2dyaWQgPC0gbWVzaGdyaWQoc2VxKQptZXNoX2dyaWRfeDEgPC0gbWVzaF9ncmlkW1sxXV0KbWVzaF9ncmlkX3gyIDwtIG1lc2hfZ3JpZFtbMl1dCiAKIyBSZS1pbml0aWFsaXplIGBtZXNoX2dyaWRgIHZhcmlhYmxlCm1lc2hfZ3JpZCA8LSBtZXNoX2dyaWRfeDEKZGltIDwtIGRpbShtZXNoX2dyaWQpCiAKIyBGaWxsIHVwIGBtZXNoX2dyaWRgIGJ5IHVzaW5nIGYoeDEsIHgyKQpmb3IgKGkgaW4gMTpkaW1bWzFdXSkKICBmb3IgKGogaW4gMTpkaW1bWzJdXSkKICAgIG1lc2hfZ3JpZFtbaSwgal1dIDwtIGYobWVzaF9ncmlkX3gxW1tpLCBqXV0sIG1lc2hfZ3JpZF94MltbaSwgal1dKQogCiMgRGlzcGxheSB0aGUgY29udG91ciBwbG90CnBsb3RfbHkoCiAgeCA9IHNlcSwKICB5ID0gc2VxLAogIHogPSBtZXNoX2dyaWQsCiAgdHlwZSA9ICJjb250b3VyIiwKICBob3ZlcmluZm8gPSAibm9uZSIsCiAgY29udG91cnMgPSBsaXN0KGNvbG9yaW5nID0gImhlYXRtYXAiKQopICU+JSBjb2xvcmJhcih0aXRsZSA9ICJWYWx1ZSBvZiBmKHgxLCB4MikiKSAlPiUgbGF5b3V0KAogIHhheGlzID0gbGlzdCh0aXRsZSA9ICJ4MSIsIHNob3d0aWNrbGFiZWxzID0gVFJVRSksCiAgeWF4aXMgPSBsaXN0KHRpdGxlID0gIngyIiwgc2hvd3RpY2tsYWJlbHMgPSBUUlVFKQopCmBgYAoKVGhlIGNvbnRvdXIgcGxvdCBhYm92ZSBpcyB0aGUgZ2VuZXJhdGVkIHZhbHVlIGZyb20gYWxsICR4XzEkIGFuZCAkeF8yJCB3aGVyZSAkLTEwIFxsZXEgeF8xLCB4XzIgXGxlcSAxMCQgaW4gJGYoeF8xLCB4XzIpJCBmdW5jdGlvbi4gVGhlIHNvbHV0aW9uIGlzIG5vd2hlcmUgaW4gdGhlIHBsb3QuClNpbmNlIHdlIHdhbnQgdG8gZmluZCBpdHMgKiptaW5pbXVtIHZhbHVlKiosIHdlIGNvdWxkIHByZWRpY3QgdGhhdCB0aGUgc29sdXRpb24gaXMgb24gdGhlIGRhcmsgcHVycGxlIGNvbG9yZWQgYXJlYS4KCiMjIyBTaW11bGF0ZWQgQW5uZWFsaW5nIEltcGxlbWVudGF0aW9uCgpgYGB7cn0KIyBJbml0aWFsaXplIHJhbmRvbSBzb2x1dGlvbgpzdGFydCA8LSBsaXN0KHgxID0gLTIsIHgyID0gNSwgdGVtcGVyYXR1cmUgPSAxMDAwKQpzdGFydCA8LSBjKHN0YXJ0LCBsaXN0KGFjY2VwdGFuY2UgPSBmKHN0YXJ0JHgxLCBzdGFydCR4MikpKQogCiMgSW5pdGlhbGl6ZSBjdXJyZW50IHNvbHV0aW9uCmN1cnJlbnQgPC0gc3RhcnQKYmVzdCA8LSBjKGN1cnJlbnQsIGFjY2VwdGFuY2UgPSBmKGN1cnJlbnQkeDEsIGN1cnJlbnQkeDIpKQogCiMgR2VuZXJhdGUgcmFuZG9tIHBvaW50ICh4MSwgeDIpCmdlbmVyYXRlIDwtIChmdW5jdGlvbigpIHJ1bmlmKDEsIC0xMCwgMTApKQoKIyBJbml0aWFsaXplIGEgbmV3IG1lc2ggZ3JpZCBmb3IgeiA9IGYoeCwgeSkKbWVzaF9ncmlkX3ggPC0gYygpCm1lc2hfZ3JpZF95IDwtIGMoKQptZXNoX2dyaWRfeiA8LSBjKCkKIAojIE1haW4gc2ltdWxhdGVkIGFubmVhbGluZyBhbGdvcml0aG0Kd2hpbGUgKGN1cnJlbnQkdGVtcGVyYXR1cmUgPiAwKSB7CiAgIyBHZW5lcmF0ZSBhIG5ldyByYW5kb20gc29sdXRpb24KICBuZXdseSA8LSBsaXN0KHgxID0gZ2VuZXJhdGUoKSwgeDIgPSBnZW5lcmF0ZSgpKQogIG5ld2x5IDwtIGMobmV3bHksIGFjY2VwdGFuY2UgPSBmKG5ld2x5JHgxLCBuZXdseSR4MikpCiAgCiAgIyBFbmVyZ3kgY2hhbmdlcyBhLmsuYSBcRGVsdGEgRQogIGNoYW5nZXMgPC0gbmV3bHkkYWNjZXB0YW5jZSAtIGN1cnJlbnQkYWNjZXB0YW5jZQogIAogIGlmIChjaGFuZ2VzIDwgMCkgewogICAgY3VycmVudCR4MSA8LSBuZXdseSR4MQogICAgY3VycmVudCR4MiA8LSBuZXdseSR4MgogICAgCiAgICBjdXJyZW50JGFjY2VwdGFuY2UgPC0gbmV3bHkkYWNjZXB0YW5jZQogICAgCiAgICAjIEFkZGluZyBhIG5ldyB2YWx1ZSBmb3IgZWFjaCBtZXNoIGdyaWQKICAgIG1lc2hfZ3JpZF94IDwtIGMobWVzaF9ncmlkX3gsIGN1cnJlbnQkeDEpCiAgICBtZXNoX2dyaWRfeSA8LSBjKG1lc2hfZ3JpZF95LCBjdXJyZW50JHgyKQogICAgbWVzaF9ncmlkX3ogPC0gYyhtZXNoX2dyaWRfeiwgY3VycmVudCRhY2NlcHRhbmNlKQogICAgCiAgICBpZiAobmV3bHkkYWNjZXB0YW5jZSA8IGJlc3QkYWNjZXB0YW5jZSkgewogICAgICBiZXN0JHgxIDwtIG5ld2x5JHgxCiAgICAgIGJlc3QkeDIgPC0gbmV3bHkkeDIKICAgICAgCiAgICAgIGJlc3QkYWNjZXB0YW5jZSA8LSBuZXdseSRhY2NlcHRhbmNlCiAgICB9CiAgfQogIGVsc2UgewogICAgIyBDb25zaWRlcmluZyBtb3ZlIHRvIHRoZSBjdXJyZW50ICh4MSwgeDIpCiAgICBQIDwtIGV4cCgoLWNoYW5nZXMpIC8gY3VycmVudCR0ZW1wZXJhdHVyZSkKICAgIFIgPC0gcnVuaWYoMSkKICAgIAogICAgaWYgKFIgPCBQKSB7CiAgICAgIGN1cnJlbnQkeDEgPC0gbmV3bHkkeDEKICAgICAgY3VycmVudCR4MiA8LSBuZXdseSR4MgogICAgfQogIH0KICAKICAjIERlY3JlYXNlIHRoZSB0ZW1wZXJhdHVyZSByYW5kb21seQogIGN1cnJlbnQkdGVtcGVyYXR1cmUgPC0gY3VycmVudCR0ZW1wZXJhdHVyZSAtIHJ1bmlmKDEsIDAuMDAwMSwgMC4wMSkKfQoKIyBSZXRyaWV2ZSB0aGUgc29sdXRpb24gYW5kIHRoZW4gcHJpbnQgaXQKc29sdXRpb24gPC0gbGlzdCh4MSA9IGJlc3QkeDEsIHgyID0gYmVzdCR4MiwgdmFsdWUgPSBiZXN0JGFjY2VwdGFuY2UpCnByaW50KHNvbHV0aW9uKQpgYGAKCkJ5IHVzaW5nIHNpbXVsYXRlZCBhbm5lYWxpbmcgYWJvdmUsIHdlIGdvdCB0aGUgc29sdXRpb24uIEl0IGlzICQoLTguMDQ5Njg5LCA5LjY2MTg3NykkIGluIHRoZSBmb3JtIG9mICQoeF8xLCB4XzIpJC4KVGhlIHZhbHVlIG9mICRmKHhfMSwgeF8yKSQgaXMgJC0xOS4yMDgxNCQuClJlbWVtYmVyIHRoYXQgdGhlIHNvbHV0aW9uIGNvdWxkIGJlIGEgYml0IGRpZmZlcmVudCBpZiB3ZSBzdGFydCBvdmVyIGFuZCBydW4gdGhlIGFsZ29yaXRobSBhZ2Fpbi4KSG93ZXZlciwgdGhlIHJlc3VsdCB3b3VsZCBiZSBhcm91bmQgJC0xOSQuCgojIyMgRGlzcGxheSB0aGUgQ29udG91ciBQbG90CgpgYGB7cn0KcGxvdF9seSgKICB4ID0gbWVzaF9ncmlkX3gsCiAgeSA9IG1lc2hfZ3JpZF95LAogIHogPSBtZXNoX2dyaWRfeiwKICB0eXBlID0gImNvbnRvdXIiLAogIGhvdmVyaW5mbyA9ICJub25lIiwKICBjb250b3VycyA9IGxpc3QoY29sb3JpbmcgPSAiaGVhdG1hcCIpCikgJT4lIGNvbG9yYmFyKHRpdGxlID0gIlZhbHVlIG9mIGYoeDEsIHgyKSIpICU+JSBsYXlvdXQoCiAgeGF4aXMgPSBsaXN0KHRpdGxlID0gIngxIiwgc2hvd3RpY2tsYWJlbHMgPSBUUlVFKSwKICB5YXhpcyA9IGxpc3QodGl0bGUgPSAieDIiLCBzaG93dGlja2xhYmVscyA9IFRSVUUpCikKYGBgCgpXZSBhbGwga25vdyB0aGF0IHRoZSBzb2x1dGlvbiBpcyBhcm91bmQgJC0xOSQgYW5kIGl0IGlzIHByb2R1Y2VkIGJ5IChhcm91bmQpICQoOC4wLCA5LjcpJC4KSGVuY2UsIGJ5IGxvb2tpbmcgYXQgdGhlIGNvbnRvdXIgcGxvdCBhYm92ZSwgdGhlIHNvbHV0aW9uIGlzIG9uIHRoZSB0aGF0IGRhcmsgcHVycGxlIGNvbG9yLgo=